home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / fg_spec.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  19.0 KB  |  475 lines
  1. (herald (assembler fg_spec t 77))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; (define-fg (fgname . parameters)
  27. ;;;   <RandomSpec>s . <fg-spec>s )
  28. ;;;
  29. ;;;   <parameter> is (<predicate> <parameter-name>)
  30. ;;;   and the <predicate> return false if the parameter passed
  31. ;;;   to create the fg was not of the right type.
  32. ;;; 
  33. ;;; <fg-spec> is one of
  34. ;;;  
  35. ;;;   (F {S|U} <FixedWidthSpec> <ValueSpec>)      -- fixed width field
  36. ;;;   (V {S|U} <VariableWidthSpec> <ValueSpec>)   -- variable width field
  37. ;;;   ({0|1} {0|1} ...) -- like (F U width value), msb first
  38. ;;;
  39. ;;;   (FG <ValueSpec> <ContextSpec>)
  40. ;;;      -- value is an FG, should be a symbol
  41. ;;;   
  42. ;;;   (DEPENDING-ON ... )
  43. ;;;      -- see selector comments below.           
  44. ;;;
  45. ;;;   (MARK <symbol>)
  46. ;;;      -- The value of <symbol> is set to the current location counter.
  47. ;;; 
  48. ;;; <FixedWidthSpec> ::= <fixnum> | <symbol> | ( <expr> )
  49. ;;; <VariableWidthSpec> ::= ( <fixnum>s )
  50. ;;; <ContextSpec> ::= ( <ContextName> . <number-or-symbol>s ) | 
  51. ;;;                   <symbol>
  52. ;;;    -- fixed case is as immediate context value, second
  53. ;;;       is when context is a parameter
  54. ;;; 
  55. ;;; 
  56. ;;; <ValueSpec> ::= <fixnum> | <symbol> | ( < expr > )
  57. ;;;    -- as a feature, an expr may include a (FROM mark label),
  58. ;;;       which will yield the displacement, when the expr is evaluated.
  59. ;;;
  60. ;;; <RandomSpec> ::= (PRINTER ...)  |
  61. ;;;                  (LOCAL <var>s) | 
  62. ;;;                  (CONTEXT <ContextSpec> )
  63.  
  64.  
  65. ;;; Runtime support for FG's is in FG.T
  66.  
  67. ;;; An FG represents a parameterized sequence of bits.
  68. ;;; The rutime representation of an FG is similar to a structure:
  69. ;;; there is a vector of values (the fg parameters, context variables,
  70. ;;; local variables, and temps).  An FG expression (named-fg (foo a b) ...)
  71. ;;; yields a procedure, that when called, will yield an FG.  All
  72. ;;; FGs returned as a result of calling the fg procedure will be of the
  73. ;;; same FG-TYPE.  The FG-TYPE contains a vector of contants
  74. ;;; (procedures, and the FG-OPS, etc), a printer, a list of indices into
  75. ;;; the ops to where subfields are, and a context (type) name.
  76.  
  77. ;;; What the FG-OPS are:  the various field specifiers are compiled
  78. ;;; into a little "program", which the various parts of the assembler
  79. ;;; are driven from.
  80.  
  81. ;;;; CONTEXT DEFINITION
  82.  
  83. ;;; A context is a set of value associated witha particular subfield 
  84. ;;; position in an FG.  When specifying a machine description,
  85. ;;; an FG can be specified in a particular context.  The (context ...)
  86. ;;; subform in a DEFINE-FG gives the name of the context (for
  87. ;;; error checking later), and the names of the elements of the context.  
  88. ;;; Someone instantiating that FG must supply values for the context,
  89. ;;; and those values are supplied in the form of a list that is
  90. ;;; isomorphic to the orginal context specification.
  91.  
  92. (define context-id car)
  93. (define context-components cdr)
  94.                              
  95. ;;; UTILITIES for hacking the FG syntax.
  96.  
  97. (define (sign-op su)
  98.   (if (eq? su 's) -1 0))
  99.  
  100. (define (augment-vals vals val)
  101.   (return (cons val vals) (length vals)))
  102.  
  103. (define (allocate-vars-slot vars)
  104.   (return (cons nil vars) (length vars)))
  105.  
  106. ;;; The var mark is needed because we are multiplexing the vars
  107. ;;; list to supply variable names/position information as well
  108. ;;; as initial values.
  109.  
  110. (define *var-mark* (cons '*var-mark* nil))
  111. (define *init-var-mark* (cons '*init-var-mark* nil))
  112.  
  113. (define (augment-vars vars val)
  114.   (return (cons `(,*var-mark* . ,val) vars) 
  115.           (length vars)))
  116.                 
  117. (define (set-initial-value var val vars)
  118.     (iterate loop ((vars vars))
  119.         (cond ((null? vars)
  120.                (error "can't set initial value of ~s in ~s" var vars))
  121.               ((eq? (car vars) var)
  122.                (set (car vars) `(,*init-var-mark* ,var . ,val)))
  123.               ((and (pair? (car vars))
  124.                     (eq? (caar vars) *init-var-mark*)
  125.                     (eq? (cadar vars) var))
  126.                (error "~s already has an initial value ~s"
  127.                       var
  128.                       vars))              
  129.               (else
  130.                (loop (cdr vars))))))
  131.  
  132. (define (is-the-var? the-var some-var)
  133.     (cond ((eq? the-var some-var) t)
  134.           ((and (pair? some-var)
  135.                 (eq? (car some-var) *init-var-mark*)
  136.                 (eq? (cadr some-var) the-var))
  137.            some-var)
  138.           (else nil)))
  139.  
  140. (define (vars-ref vars key)
  141.   (fx- (fx- (length vars)
  142.             (or (pos is-the-var? key vars)
  143.                 (error "variable ~s not found in ~s" key vars)))
  144.        1))
  145.  
  146. ;;;; FG DEFINITION PROCESSING
  147.                                 
  148. (define (process-define-fg name parameters specs)
  149.     (process-define-fg-1 name parameters specs nil))
  150.  
  151. (define (process-define-data-fg name parameters specs)
  152.     (process-define-fg-1 name parameters specs t))
  153.  
  154. (define (process-define-fg-1 name parameters specs data?)
  155.   (receive (locals context printer fg-specs)
  156.            (process-random-specs specs)
  157.     ;; construct vars backwards
  158.     (let* ((bvl   (map (lambda (x) (if (pair? x) (cadr x) x)) parameters))
  159.            (vars (append (reverse locals)
  160.                          (reverse bvl)
  161.                          (reverse (context-components context))))
  162.            (vals '() ))
  163.       (iterate loop ((fg-specs fg-specs)
  164.                      (ops's '())
  165.                      (vars vars)
  166.                      (vals vals)
  167.                      (sf's '()))
  168.         (cond ((null? fg-specs)
  169.                ;; put together the code
  170.                (let ((fgt-name (generate-symbol 'fg-type)))
  171.                   `(let ((,fgt-name 
  172.                           ,(fgt-code printer vars ops's vals context sf's data?)))
  173.                     ,(fg-code name bvl parameters fgt-name context locals vars)))
  174.                )
  175.               (else
  176.                (receive (ops vars vals)
  177.                         (process-fg-spec (car fg-specs) vars vals)
  178.                  (let ((ops's-length (length ops's)))
  179.                    (loop (cdr fg-specs)
  180.                          (append! ops's ops)
  181.                          vars
  182.                          vals
  183.                          ;; collect sf positon information.
  184.                          (cond ((or (eq? (caar fg-specs) 'fg)
  185.                                     (eq? (caar fg-specs) 'fg-named))
  186.                                 (cons ops's-length sf's))
  187.                                (else sf's)))))))))))
  188.  
  189.  
  190. ;;; Collect LOCAL PRINTER and CONTEXT specs out of a define-fg form
  191.  
  192. (define (process-random-specs specs)
  193.    (iterate loop ((specs specs) (locals '()) (context nil) (printer nil))
  194.      (let ((spec (car specs)))
  195.        (cond ((eq? (car spec) 'local)
  196.               (loop (cdr specs) (cdr spec) context printer))
  197.              ((eq? (car spec) 'printer)
  198.               (loop (cdr specs) locals context (cdr spec)))
  199.              ((eq? (car spec) 'context)
  200.               (loop (cdr specs) locals (cadr spec) printer))
  201.              (else
  202.               (return locals context printer specs))))))
  203.  
  204.  
  205. ;;; Returns ops for this spec, new vars, and new vals
  206.  
  207. (define (process-fg-spec spec vars vals)
  208.   (case (car spec)
  209.     ((f) 
  210.      (process-f-spec spec vars vals))
  211.     ((0 1)
  212.      (receive (width value) 
  213.               (bits->fixnum spec)
  214.         (process-f-spec `(f u ,width ,value) vars vals)))
  215.     ((v)
  216.      (process-v-spec spec vars vals))
  217.     ((depending-on)
  218.      (process-d-o-spec spec vars vals))
  219.     ((fg)
  220.      (process-subfg-spec (cdr spec) vars vals nil))
  221.     ((fg-named)
  222.      (process-subfg-spec (cddr spec) vars vals (cadr spec)))
  223.     ((mark)
  224.      (destructure (((#f mark-name) spec))
  225.         (return `(,wop/mark ,(vars-ref vars mark-name))
  226.                 vars
  227.                 vals)))
  228.     (else
  229.      (error "unrecognized fg spec: ~s" spec))))
  230.  
  231. ;;; Convert a list of bits to a fixnum.
  232.  
  233. (import t-implementation-env *bits-per-fixnum*)
  234. (define (bits->fixnum bits-in)
  235.   (iterate loop ((l 0) (num 0) (bits bits-in))
  236.      (cond ((null? bits)
  237.             (return l num))
  238.            ((fx>= l *bits-per-fixnum*)
  239.              (error "too many bits~%  (bits->fixnum ~s)" bits-in))
  240.            (else
  241.             (loop (fx+ l 1) (fx+ (fixnum-ashl num 1) (car bits)) (cdr bits))))))
  242.  
  243.  
  244. (define (process-f-spec spec vars vals)
  245.   (destructure (((#f su w-exp v-exp) spec))
  246.     (receive (vop voc1 vals)
  247.              (fg-value-op v-exp vars vals)
  248.       (receive (wop wopcs vars vals)
  249.                (process-f-width-exp w-exp vars vals)
  250.         (return `(,wop ,(sign-op su) ,@wopcs ,vop ,voc1)
  251.                 vars
  252.                 vals)))))
  253.  
  254. (define (process-v-spec spec vars vals)
  255.   (destructure (((#f su options v-exp) spec))
  256.     (receive (vop voc1 vals) (fg-value-op v-exp vars vals)
  257.       (receive (vars var-pos) (allocate-vars-slot vars)
  258.         (receive (vals val-pos) (augment-vals vals options)
  259.           (return `(,wop/var ,(sign-op su)
  260.                              ,var-pos  ;cw-i
  261.                              ,val-pos  ;opt-i
  262.                              ,vop ,voc1)
  263.                   vars
  264.                   vals))))))
  265.  
  266. ;;; DEPENDING-ON selectors
  267.  
  268. ;;; The selector in a D-O is used to calculate the number of bits
  269. ;;; needed to represent the field, given the displacement specified
  270. ;;; in the D-O, and the width of this field used in computing that 
  271. ;;; displacement.   
  272. ;;;
  273. ;;; The selector is specified as 
  274. ;;;
  275. ;;;     ( <selector-name> ( <width-name> <min-width> ) <displ-name> )
  276. ;;;
  277. ;;; <width-name> and <displ-name> are names of variables local to this fg.  
  278. ;;; The selector is passed these (TAS figures out initial values) and
  279. ;;; must return new values.  The two variables will be set to the final
  280. ;;; width and displacement values.  The last form in the D-O is an expression
  281. ;;; that will be evaluated to get an fg (or list of them) to use as the
  282. ;;; D-O.  That fg is obligated to be exactly as wide as the selector 
  283. ;;; computed it would be (that width will be the value of the variable
  284. ;;; named <width-name>.
  285. ;;;
  286. ;;; The returned displacement must be measured from the same spot that
  287. ;;; the passed-in displacement was measured from.
  288. ;;;
  289. ;;; This routine 'wraps' the selector so that its return values will
  290. ;;; be available to the fg expression.
  291.  
  292. ;;; Who sets what fields ina D-O spec:
  293. ;;; "count" sets the sdf-number slot in VARS to the index in the
  294. ;;; SDFS vector of the sdf for the fg.  The sdf is also stored in
  295. ;;; the sdf-i slot of VARS.  The mark-i slot of VARS is an index
  296. ;;; in the MARKS vector of the mark for the D-O; "count" also
  297. ;;; initializes this slot.
  298.  
  299. (define (process-d-o-spec spec vars vals)
  300.   (destructure (((#f (#f m-name label) 
  301.                      (sel (w-name min) d-name) 
  302.                      fg-expr) 
  303.                  spec))
  304.     (let ((width-i (vars-ref vars w-name))
  305.           (displ-i (vars-ref vars d-name))
  306.           (mark-i  (vars-ref vars m-name)) )
  307.       (receive (vars sdf-i)
  308.                (augment-vars vars 
  309.                 `(cons-sdf ,label ,sel ,min '(,width-i . ,displ-i)))
  310.         (receive (vals fg-expr-i)
  311.                  (augment-vals vals (compile-expr fg-expr vars))
  312.           (receive (vars sdf#-i) (allocate-vars-slot vars)
  313.             (return `(,wop/d-o ,sdf#-i ,sdf-i ,mark-i ,fg-expr-i)
  314.                     vars 
  315.                     vals)))))))
  316.              
  317. ;;; This used to be called 'subfield-in-context'
  318. ;;;
  319. ;;; format: (FG <var> <context-exp>) or (FG <expr> <context-exp>)  
  320. ;;; <expr> is evaluated at compress time so context is available, and 
  321. ;;; displacements are not. 
  322. ;;; For (FG <expr> ...), the VAL index of the <expr>-procedure is stored in 
  323. ;;; the VAR slot allocated for the subfg
  324. ;;;
  325. ;;; (FG-NAMED <name> <expr> <context-exp>) - sets local variable <name> 
  326. ;;; to the value of <expr>.
  327.  
  328. (define (process-subfg-spec spec vars vals name)
  329.   (destructure (((fg context) spec))
  330.     (if (and name (symbol? fg))
  331.         (error "2 names for subfield: ~s and ~s" fg name))
  332.     (receive (vop voc1 vals)
  333.              ;; get context guy.
  334.              (cond ((false? context)
  335.                     (receive (vals val-pos)
  336.                              (augment-vals vals "No context given in fg")
  337.                       (return vop/const val-pos vals)))
  338.                    (else
  339.                     (fg-value-op context vars vals)))
  340.        ;; get subfg; process if expr
  341.        (receive (var-index vars vals)
  342.                 (cond ((symbol? fg) 
  343.                        (return (vars-ref vars fg) vars vals))
  344.                       (else ; have an <expr> for subfg
  345.                        (receive (vals fg-expr-index)
  346.                                 (augment-vals vals (compile-expr fg vars))
  347.                           (cond (name   
  348.                                  (set-initial-value name fg-expr-index vars)
  349.                                  (return (vars-ref vars name) vars vals))
  350.                                 (else
  351.                                  (receive (vars var-pos)
  352.                                           (augment-vars vars 
  353.                                                         fg-expr-index)
  354.                                     (return var-pos vars vals)))))))
  355.           (return `(,wop/subfield-ic ,var-index ,vop ,voc1)
  356.                   vars
  357.                   vals)))))
  358.  
  359. ;;; FG processing utilities.
  360.  
  361. ;;; returns <v-op> <v-opcode1> and new <vals>
  362. (define (fg-value-op v-exp vars vals)
  363.   (xcond ((fixnum? v-exp)
  364.           (receive (n-vals val-pos) (augment-vals vals v-exp)
  365.             (return vop/const val-pos n-vals)))
  366.          ((symbol? v-exp)
  367.           (return vop/var (vars-ref vars v-exp) vals))
  368.          ((pair? v-exp)
  369.           (cond ((or (eq? (car v-exp) 'from) (eq? (car v-exp) 'disp))
  370.                  (error "disp/from return not supported")
  371.                  (return vop/disp
  372.                          (vars-ref vars (cadr v-exp))  ; marker
  373.                          (vars-ref vars (caddr v-exp)) ; destination
  374.                          vals))
  375.                 (else
  376.                  (receive (n-vals val-pos)
  377.                           (augment-vals vals (compile-expr v-exp vars))
  378.                    (return vop/proc val-pos n-vals)))))))
  379.  
  380. (define (process-f-width-exp w-exp vars vals)
  381.   (cond ((fixnum? w-exp)
  382.          (return wop/fix `(,w-exp) vars vals))
  383.         ((symbol? w-exp)
  384.          (return wop/@fix `(,(vars-ref vars w-exp)) vars vals))
  385.         (else
  386.          (receive (vals val-pos)
  387.                   (augment-vals vals (compile-expr w-exp vars))
  388.            (receive (vars var-pos)
  389.                     (allocate-vars-slot vars)
  390.              (return wop/proc `(,var-pos ,val-pos) vars vals))))))
  391.  
  392.  
  393. ;;; Put fg code together; called with information collected by PROCESS- guys.
  394.  
  395. ;;; Construct code for fg-type.
  396.  
  397. (define (fgt-code pr vars ops vals context sf's data?)
  398.   `(cons-fg-type ,(compile-print-expr `(format stream ,@pr) '(stream) vars)
  399.                  ',ops
  400.                  (vector ,@(map (lambda (x)
  401.                                   (cond ((and (pair? x)
  402.                                               (neq? (car x) 'lambda))
  403.                                          `',x)
  404.                                         (else x)))
  405.                                 (reverse! vals)))
  406.                  ',(context-id context)
  407.                  ',(fixup-sf's sf's)
  408.                  ,(length (context-components context))
  409.                  ',data?))
  410.                               
  411. ;;; Construct code for fg object itself.
  412.  
  413. (define (fg-code name bvl parameters type-var-name context locals vars)
  414.   `(object 
  415.      (named-lambda ,name ,bvl
  416.         ,(cond ((any? pair? parameters)
  417.                 `(let (,@(map list bvl parameters))
  418.                    (and ,@bvl 
  419.                         ,(fg-code-1 bvl type-var-name context locals vars))))
  420.                (else
  421.                 (fg-code-1 bvl type-var-name context locals vars))))
  422.      ((get-fg-type self) ,type-var-name)))
  423.  
  424. (define (fg-code-1 bvl type-var-name context locals vars)
  425.    `(cons-fg ,type-var-name
  426.              (vector ,@(append (map (lambda (()) ''())
  427.                                     (context-components context))
  428.                                bvl
  429.                                (map (lambda (v)
  430.                                        (hack-initial-value v vars))
  431.                                     locals)
  432.                                (make-var-slot-code vars)
  433.                                ))))
  434.  
  435. (define (hack-initial-value var vars)
  436.     (cond ((any (lambda (some-var) (is-the-var? var some-var)) vars)
  437.            => (lambda (v) (cond ((pair? v) (cddr v))
  438.                                 (else ''()))))
  439.           (else
  440.            ''())))
  441.  
  442. ;;; Horrible horrible.  We keep track of where in an FG the subfields are
  443. ;;; so that CONTEXTIFY need not scan the fg.  sf's is a backward list of 
  444. ;;; positions in the fg-ops lists, this take succesive differences so 
  445. ;;; that contextify has an even easier time.
  446. ;;; (fixup-sf's '(23 19 3))  => (3 16 4)
  447.  
  448. (define (fixup-sf's sf's)
  449.   (do ((prev sf's (cdr prev))
  450.        (cur (cdr sf's) (cdr cur)))
  451.       ((null? cur) (reverse! sf's))
  452.     (set (car prev) (fx- (car prev) (car cur)))))
  453.                                             
  454. ;;; As the PROCESS- guys build of the list of things in the FG-VARS vector,
  455. ;;; some things are marked as needing to be evaluated by wrapping them
  456. ;;; with (*var-mark* ...);  MAKE-VAR-SLOT-CODE takes the marks out, and
  457. ;;; puts in quotes.  Note this results ina reversed list, and the input
  458. ;;; is only processed up to the first symbol.   This is because VARS
  459. ;;; starts out with the context names, parameter names, and local variable
  460. ;;; names in it so the PROCESS- guys can compile references to those things.
  461. ;;; BUT! there are no return for the local and context vars when the fg 
  462. ;;; is made, but there are parameter return, so blah blah.
  463.  
  464. (define (make-var-slot-code vars)
  465.   (iterate loop ((l vars) (var-slots '()))
  466.      (cond ((null? l) 
  467.             var-slots)
  468.            ((null? (car l)) 
  469.             (loop (cdr l) (cons ''() var-slots)))
  470.            ((and (pair? (car l)) 
  471.                  (eq? (caar l) *var-mark*))
  472.             (loop (cdr l) (cons (cdar l) var-slots)))
  473.            (else
  474.             var-slots))))
  475.